perm filename QUEENS.LSP[E82,JMC] blob
sn#677230 filedate 1982-09-14 generic text, type C, neo UTF8
COMMENT ā VALID 00008 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 queens.lsp[e82,jmc] Programs for the n queens problem
C00006 00003 (defun moves (pos) ((lambda (x)
C00013 00004 When a square is found unoccupiable, kill deletes it from the
C00015 00005 The function expect(n) gives the expected number of solutions to
C00017 00006 bfun
C00021 00007 bfun
C00023 00008
C00024 ENDMK
Cā;
;;; queens.lsp[e82,jmc] Programs for the n queens problem
(defun queens ; top level n queens program
; value is a list of solutions extending a position
(pos ; position as a sequence of occupied squares
found ; a list of the solutions already found
exc) ; a list of the positions whose continuations
; have been explored. Positions that contain
; them are excluded by symmetry.
(if (or (contains pos exc) (lost pos))
found
(won pos)
(cons (outform pos) found)
(queens1 pos found exc (moves pos))))
(defun queens1 ; scans row, column or (rarely) diagonal
; value is list of solutions
(pos ; position as a sequence of occupied squares
found ; list of positions already found
exc ; positions whose continuations have been explored
l) ; list of remaining moves to be considered
(if (null l)
found
(queens1 pos
(queens (update pos (car l)) found exc)
exc ; needs to be updated
(cdr l))))
;;; functions for hand computation
(defun init (n2) (prog ()
(setq n n2)
(setq n1 (sub1 n))
(array bd fixnum n n)
(setq m -1)))
(defun try (x y)
(if (not (zerop (bd x y)))
'lose
(prog ()
(setq m (plus m 2))
(store (bd x y) (add1 m))
(do i (minus n) (1+ i) (= i n)
(if (and (in1 (+ x i) y) (zerop (bd (+ x i) y)))
(store (bd (+ x i) y) m))
(if (and (in1 x (+ y i)) (zerop (bd x (+ y i))))
(store (bd x (+ y i)) m))
(if (and (in1 (+ x i) (+ y i)) (zerop (bd (+ x i) (+ y i))))
(store (bd (+ x i) (+ y i)) m))
(if (and (in1 (+ x i) (- y i)) (zerop (bd (+ x i) (- y i))))
(store (bd (+ x i) (- y i)) m))
)
(show)
)
)
)
(defun b () (prog ()
(do i 0 (1+ i) (= i n)
(do j 0 (1+ j) (= j n) (if (or (equal m (bd i j))
(equal (1+ m) (bd i j)))
(store (bd i j) 0))))
(show)
(setq m (- m 2))))
(defun in1 (x y) (and (lessp -1 x) (lessp -1 y) (lessp x n) (lessp y n)))
(defun ko (x y) (if (zerop (bd x y))
(prog () (store (bd x y) (- n 3)) (show))
'lose))
(defun moves (pos) ((lambda (x)
) (classify pos)))
;;; A position involves
;;; 1. a board. Each square has its order of occupation or its
;;; order of exclusion or 0 if it's still available.
;;; 2. the rows and columns have their associated numbers of
;;; free squares.
;;; 3. Optionally, the diagonals have their numbers of free squares
;;; and the numbers of unexcluded diagonals of both slopes are listed.
;;;
;;; 4. Perhaps the diagonals of each occupied square should be listed.
;;; The elements of these arrays are lists of available squares in the line.
(array rows t (1- n))
(array columns t (1- n))
;;; (bd i j) is the generation number that kills square (i,j).
(array bd t (1- n) (1- n))
(defun init (n2) (prog ()
(setq n n2)
(setq n1 (sub1 n))
(array bd fixnum n n)
;;; for storing the occupancy of diagonals
(array pdiag fixnum (1- (* 2 n)))
(array ndiag fixnum (1- (* 2 n)))
(setq m -1)))
(defun contains (pos exc) nil) ; temporarily ignoring symmetry
(defun fixup (x) (prog (z)
(if (eq pos pos1) (return x))
(setq z (commontail pos pos1))
(do w z w (eq w pos1) (b))
(uplist pos)
(return x)))
(defun uplist (p) (if (equal p pos1) nil (prog ()
(uplist (cdr p))
(update (caar p) (cdar p)))))
(defun update (x y)
(prog ()
(setq m (plus m 2))
(store (bd x y) (add1 m))
(setq pos1 (cons (cons x y) pos1)
(do i (minus n) (1+ i) (= i n)
(if (and (in1 (+ x i) y) (zerop (bd (+ x i) y)))
(store (bd (+ x i) y) m))
(if (and (in1 x (+ y i)) (zerop (bd x (+ y i))))
(store (bd x (+ y i)) m))
(if (and (in1 (+ x i) (+ y i)) (zerop (bd (+ x i) (+ y i))))
(store (bd (+ x i) (+ y i)) m))
(if (and (in1 (+ x i) (- y i)) (zerop (bd (+ x i) (- y i))))
(store (bd (+ x i) (- y i)) m))
)
)
)
(defun b () (prog ()
(setq pos1 (cdr pos1))
(do i 0 (1+ i) (= i n)
(do j 0 (1+ j) (= j n) (if (or (equal m (bd i j))
(equal (1+ m) (bd i j)))
(store (bd i j) 0))))
(show)
(setq m (- m 2))))
(defun in1 (x y) (and (lessp -1 x) (lessp -1 y) (lessp x n) (lessp y n)))
;;; Delete squares from board that kill whole rows or columns.
(setq u (append liverows livecolumns))
(do ((l (car u) (cdr l)))
((null l) nil)
(if (changed (car l))
(if (killable (car l)) (kill (killers (car l))))))
If in examining a line (row or column), there are no free squares,
the line is dead and we want a THROW up to failing the search
If there is only one, then we want to put a queen there, THROW up
to a level that marks of the squares covered by the queen and
starts looking for killed squares all over. Some lines will be
unchanged by this process, and any square killed will still be
dead. If we are using dates to mark squares, we can therefore
continue with the same dates since there will be no backtracking
within this process.
Programming issues:
1. killable and killers share computation. We can use setqs to
extra variables or we can cause the first function to be caused
to set hidden variables. All are bad. The programs for killable
and killers should state that they share information, and a
source-to-source compiler should do the work.
2. We need a general mechanism for iterating over a list u where
at any time we may add elements to or delete elements from u.
3. We need general methods for doing a process until it can't be
done anymore.
(defun prekill (line) ((lambda
(n)
(if (zerop n) (*throw 'loss nil)
(= n 1) (*throw 'unique line))
(defun prekill
(line)
(do ((l line (cdr l))
(first nil)
(second nil)
(third nil))
((null l) (if (null first)
(throw 'noroom nil)
(null second)
(throw 'oneleft l)
(
;;; When a square is found unoccupiable, kill deletes it from the
;;; board if it isn't already deleted in the present or earlier
;;; generation. It also deletes the square from the row and
;;; column lists and puts the row and column on the queue of
;;; lines from which further killers are to be found.
(defun kill (x gen)
(prog (i j) (setq i (car x)) (setq j (cdr x))
(if (< gen (bd i j))
(prog ()
(store (bd i j) gen)
(store (columns i) (delete x (columns i)))
(store (rows j) (delete x (rows j)))
(setq queue (cons i (cons j queue)))))))
(defun rowkillers (row gen)
(prog ()
(do (j 0 (1+ j)) (cc 0 (if
;;; The function expect(n) gives the expected number of solutions to
;;; the n queens problem where we suppose that the probability of
;;; a square in a row being attacked by a queen in some previous
;;; row is the fraction of squares in the row attacked by a random
;;; square in the previous row. expect(8) = 327.3 while the actual
;;; number of solutions is 92, which suggests that there are some
;;; number-theoretic obstacles to solutions. This in turn suggests
;;; that there may be better algorithms than simple backtracking
;;; for finding all solutions, i.e. algorithms that use some number
;;; theory.
;bfun
(defun expect (n)
(do ((i 1 (1+ i))
(a (difference 1 (quotient 2.0 n)))
(b (quotient 2.0 (expt n 2)))
(s (fact n)
(times s
(expt
(plus a (times b i))
(- n i)))))
((> i n) s)))
(expect 8.)
;efun
(defun trprint (x) (prog2 (print x) x))
(defun fact (n) (if (zerop n) 1 (times n (fact (sub1 n)))))
;end
(expect 20.)
327.333477
8.113655E+8
6.54283845E+12
;bfun
;;; (k3c u) is the list of squares that might kill a column with three
;;; unexcluded squares.
(defun k3c (u)
((lambda (d)
(if (= (- (cdadr u) (cdaddr u)) d)
(list (cons (+ (caar u) d) (cdadr u))
(cons (- (caar u) d) (cdadr u)))
nil))
(- (cdar u) (cdadr u))))
;;; (k2c u) is the list of squares that might kill a column with two
;;; unexcluded squares.
(defun k2c (u)
((lambda (d)
(if
(evenp d)
(append
((lambda (d1) (list
(cons (+ (caar u) d1) (- (cdar u) d1))
(cons (- (caar u) d1) (- (cdar u) d1))))
(quotient d 2))
(k2c1 u d))
(k2c1 u d)
))
(- (cdar u) (cdadr u))))
;;; k2c1 called by k2c gets the killing squares when there are two
;;; squares left in a column and difference is odd.
(defun k2c1 (u d) (list
(cons (+ (caar u) d) (cdar u))
(cons (- (caar u) d) (cdar u))
(cons (+ (caadr u) d) (cdadr u))
(cons (- (caadr u) d) (cdadr u))
))
;;; (k3r u) is the list of squares that might kill a row with three
;;; unexcluded squares.
(defun k3r (u)
((lambda (d)
(if (= (- (caadr u) (caaddr u)) d)
(list (cons (caadr u) (+ (cdar u) d))
(cons (caadr u) (- (cdar u) d)))
nil))
(- (caar u) (caadr u))))
;;; (k2r u) is the list of squares that might kill a row with two
;;; unexcluded squares.
(defun k2r (u)
((lambda (d)
(if
(evenp d)
(append
((lambda (d1) (list
(cons (- (caar u) d1) (+ (cdadr u) d1))
(cons (- (caar u) d1) (- (cdadr u) d1))
))
(quotient d 2))
(k2r1 u d))
(k2r1 u d)
))
(- (caar u) (caadr u))))
;;; k2r1 called by k2r gets the killing squares when there are two
;;; squares left in a row and difference is odd.
(defun k2r1 (u d) (list
(cons (caar u) (+ (cdar u) d))
(cons (caar u) (- (cdar u) d))
(cons (caadr u) (+ (cdadr u) d))
(cons (caadr u) (- (cdadr u) d))
))
;efun
;end
;bfun
;;; contents of a square
(defun bd1 (sq) (bd (car sq) (cdr sq)))
;;; marks a square unavailable
(defun kill1 (sq) (store (bd (car sq) (cdr sq)) nil))
;;; (move sq) updates the board when a move is made to sq
(defun move (sq)
(prog (x y killed)
(setq killed nil)
(setq x (car sq))
(setq y (cdr sq))
(kill sq) ; marks a square as unavailable.
(do ((l (row sq) (cdr l))) ((null l)) (kill (car l)))
(do ((l (col sq) (cdr l))) ((null l)) (kill (car l)))
(do ((l (pdiag sq) (cdr l))) ((null l)) (kill (car l)))
(do ((l (ndiag sq) (cdr l))) ((null l)) (kill (car l)))
(setq stack (cons killed stack))
)
)
)
;;; (kill sq) marks a square as unavailable.
(defun kill (sq)
(if (bd1 sq)
(prog ()
(store (bd (car sq) (cdr sq)) nil)
(setq killed (cons sq killed))
)
)
)
(defun revert ()
(do ((l (car stack) (cdr l)))
((null l) (setq stack (cdr stack)) 'reverted)
(store (bd (caar l) (cdar l)) t)
)
)
)
;efun
;end